Shareware Grab Bag/Shareware Grab Bag.iso/020/modula.arc/FUNCTION.MOD

Modula Implementation | 1986-03-26 | 4.7 KB | 277 lines

IMPLEMENTATION MODULE Functions;

FROM InOut   IMPORT Write, WriteLn, WriteString, WriteCard;
FROM Strings IMPORT Copy, Length, Pos;
FROM RealInOut IMPORT WriteReal;


PROCEDURE CardMin( a,b : CARDINAL) : CARDINAL;
BEGIN
  IF b < a THEN
     RETURN(b);
   ELSE
     RETURN(a);
  END;
END CardMin;


PROCEDURE IntMin( a,b : INTEGER) : INTEGER;
BEGIN
  IF b < a THEN
     RETURN(b);
   ELSE
     RETURN(a);
  END;
END IntMin;


PROCEDURE RealMin( a,b : REAL) : REAL;
BEGIN
  IF b < a THEN
     RETURN(b);
   ELSE
     RETURN(a);
  END;
END RealMin;


PROCEDURE CardMax( a,b : CARDINAL) : CARDINAL;
BEGIN
  IF b > a THEN
     RETURN(b);
   ELSE
     RETURN(a);
  END;
END CardMax;

PROCEDURE IntMax( a,b : INTEGER) : INTEGER;
BEGIN
  IF b > a THEN
     RETURN(b);
   ELSE
     RETURN(a);
  END;
END IntMax;


PROCEDURE RealMax( a,b : REAL) : REAL;
BEGIN
  IF b > a THEN
    RETURN(b);
   ELSE
     RETURN(a);
  END;
END RealMax;


PROCEDURE RightPad(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR;
                   i : CARDINAL);
VAR
 c,q : CARDINAL;
BEGIN
 c := Length(source);
 Copy(source,0,c,dest);
 IF (c < i) THEN
   FOR q := c TO i-1 DO
     dest[q] := ' ';
   END;   (* for *)
 END;  (* if *)
 dest[i] := CHR(0);
END RightPad;


PROCEDURE LeftPad(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR;
                   i : CARDINAL);
VAR
 c,f,q : CARDINAL;
BEGIN
 c := Length(source);
 Copy(source,0,c,dest);
 f := i - c;
 IF f > 0 THEN
   FOR q := c TO 0 BY -1 DO
     dest[q+f] := dest[q];
   END;
   FOR q := 0 TO f-1 DO
     dest[q] := ' ';
   END;
   dest[i] := CHR(0);
 END;
END LeftPad;


PROCEDURE ToSpaces(VAR dest : ARRAY OF CHAR; i : CARDINAL);
VAR
 q : CARDINAL;
BEGIN
 FOR q := 0 TO i-1 DO
   dest[q] := ' ';
 END;
 dest[i] := CHR(0);
END ToSpaces;


PROCEDURE RightTrim(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR);
VAR
 c,q : CARDINAL;
BEGIN
 c := Length(source);
 Copy(source,0,c,dest);
 WHILE dest[c] = ' ' DO
   DEC(c);
 END;   (* while *)
 IF c < Length(source) THEN
  dest[c+1] := CHR(0);
 END;
END RightTrim;


PROCEDURE LeftTrim(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR);
VAR
 c,d,q : CARDINAL;
BEGIN
 c := Length(source);
 Copy(source,0,c,dest);
 q := 0;
 WHILE dest[q] = ' ' DO
   INC(q);
 END;   (* while *)
 IF q <> 0 THEN
   FOR d := q TO c DO
      dest[d-q] := dest[d];
   END;
   dest[c-q] := CHR(0);
 END;
END LeftTrim;


PROCEDURE LeftString(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR;
                     i : CARDINAL);
VAR
 c,d,q : CARDINAL;
BEGIN
  Copy(source,0,i,dest);
END LeftString;


PROCEDURE RightString(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR;
                     i : CARDINAL);
VAR
 c,d,q : CARDINAL;
BEGIN
  c := Length(source);
  q := c-i;
  FOR d := 0 TO i DO
    dest[d] := source[q+d];
  END;
  dest[i] := CHR(0);
END RightString;


PROCEDURE RepeatString(VAR dest : ARRAY OF CHAR; ch : CHAR; i : CARDINAL);
VAR
 c : CARDINAL;
BEGIN
 FOR c := 0 TO i DO
   dest[c] := ch;
 END;
 dest[i] := CHR(0);
END RepeatString;


PROCEDURE StringReplace(VAR dest : ARRAY OF CHAR; ch1,ch2 : CHAR);
VAR
 a,h : CARDINAL;
BEGIN
  h := HIGH(dest);
  a := Pos(ch1,dest);
  WHILE a <= h DO
    dest[a] := ch2;
    a := Pos(ch1,dest);
  END;
END StringReplace;


PROCEDURE MidString(VAR dest : ARRAY OF CHAR; source : ARRAY OF CHAR;
                    beg,len : CARDINAL);

VAR
  i,k : CARDINAL;
BEGIN
  k := CardMin(len,Length(source));
  FOR i := 0 TO k-1 DO
    dest[i] := source[beg+i];
  END;
  dest[k] := CHR(0);
END MidString;


PROCEDURE RealSign(x : REAL) : REAL;
BEGIN
 IF x < 0.0 THEN
   RETURN(-1.0);
  ELSE
   RETURN(1.0);
 END;
END RealSign;

PROCEDURE Round( x : REAL) : REAL;
VAR
 f,g,k : REAL;
BEGIN
 f := ABS(x) + 0.00501;
 k := f * 100.0;
 g := k / 100.0;
 g := g * RealSign(x);
 RETURN(g);
END Round;


PROCEDURE RecHi( recno, filelen : CARDINAL) : CARDINAL;
VAR
 rechi : CARDINAL;
 RECHI,HI,RECNO,FILELEN : REAL;
BEGIN
 HI := 6.5536E4;

 RECNO := FLOAT(recno-1);
 FILELEN := FLOAT(filelen);
 RECHI := RECNO * FILELEN;

 IF RECHI <= (HI-1.0) THEN
    RETURN(0);
 ELSE
    rechi := 0;
    WHILE RECHI > (HI-1.0) DO
      RECHI := RECHI - HI;
      INC(rechi);
    END;
    RETURN(rechi);
 END;
END RecHi;


PROCEDURE RecLo( recno, filelen : CARDINAL) : CARDINAL;
VAR
 RECLO,HI,RECNO,FILELEN : REAL;
BEGIN
 HI := 6.5536E4;

 RECNO := FLOAT(recno-1);
 FILELEN := FLOAT(filelen);
 RECLO := RECNO * FILELEN;

 IF RECLO <= (HI-1.0) THEN
   RETURN(TRUNC(RECLO));
 ELSE
   WHILE RECLO > (HI-1.0) DO
     RECLO := RECLO - HI;
   END;
   RETURN(TRUNC(RECLO));
 END;
END RecLo;


END Functions.